home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_100 / 176_01 / xllist.c < prev    next >
Text File  |  1985-12-19  |  19KB  |  838 lines
  1. /* xllist - xlisp built-in list functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "overflow"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE ***xlstack;
  14. extern NODE *s_unbound;
  15. extern NODE *true;
  16.  
  17. /* external routines */
  18. extern int eq(),eql(),equal();
  19.  
  20. /* forward declarations */
  21. FORWARD NODE *cxr();
  22. FORWARD NODE *nth(),*assoc();
  23. FORWARD NODE *subst(),*sublis(),*map();
  24. FORWARD NODE *cequal();
  25.  
  26. /* cxr functions */
  27. NODE *xcar(args) NODE *args; { return (cxr(args,"a")); }
  28. NODE *xcdr(args) NODE *args; { return (cxr(args,"d")); }
  29.  
  30. /* cxxr functions */
  31. NODE *xcaar(args) NODE *args; { return (cxr(args,"aa")); }
  32. NODE *xcadr(args) NODE *args; { return (cxr(args,"da")); }
  33. NODE *xcdar(args) NODE *args; { return (cxr(args,"ad")); }
  34. NODE *xcddr(args) NODE *args; { return (cxr(args,"dd")); }
  35.  
  36. /* cxxxr functions */
  37. NODE *xcaaar(args) NODE *args; { return (cxr(args,"aaa")); }
  38. NODE *xcaadr(args) NODE *args; { return (cxr(args,"daa")); }
  39. NODE *xcadar(args) NODE *args; { return (cxr(args,"ada")); }
  40. NODE *xcaddr(args) NODE *args; { return (cxr(args,"dda")); }
  41. NODE *xcdaar(args) NODE *args; { return (cxr(args,"aad")); }
  42. NODE *xcdadr(args) NODE *args; { return (cxr(args,"dad")); }
  43. NODE *xcddar(args) NODE *args; { return (cxr(args,"add")); }
  44. NODE *xcdddr(args) NODE *args; { return (cxr(args,"ddd")); }
  45.  
  46. /* cxxxxr functions */
  47. NODE *xcaaaar(args) NODE *args; { return (cxr(args,"aaaa")); }
  48. NODE *xcaaadr(args) NODE *args; { return (cxr(args,"daaa")); }
  49. NODE *xcaadar(args) NODE *args; { return (cxr(args,"adaa")); }
  50. NODE *xcaaddr(args) NODE *args; { return (cxr(args,"ddaa")); }
  51. NODE *xcadaar(args) NODE *args; { return (cxr(args,"aada")); }
  52. NODE *xcadadr(args) NODE *args; { return (cxr(args,"dada")); }
  53. NODE *xcaddar(args) NODE *args; { return (cxr(args,"adda")); }
  54. NODE *xcadddr(args) NODE *args; { return (cxr(args,"ddda")); }
  55. NODE *xcdaaar(args) NODE *args; { return (cxr(args,"aaad")); }
  56. NODE *xcdaadr(args) NODE *args; { return (cxr(args,"daad")); }
  57. NODE *xcdadar(args) NODE *args; { return (cxr(args,"adad")); }
  58. NODE *xcdaddr(args) NODE *args; { return (cxr(args,"ddad")); }
  59. NODE *xcddaar(args) NODE *args; { return (cxr(args,"aadd")); }
  60. NODE *xcddadr(args) NODE *args; { return (cxr(args,"dadd")); }
  61. NODE *xcdddar(args) NODE *args; { return (cxr(args,"addd")); }
  62. NODE *xcddddr(args) NODE *args; { return (cxr(args,"dddd")); }
  63.  
  64. /* cxr - common car/cdr routine */
  65. LOCAL NODE *cxr(args,adstr)
  66.   NODE *args; char *adstr;
  67. {
  68.     NODE *list;
  69.  
  70.     /* get the list */
  71.     list = xlmatch(LIST,&args);
  72.     xllastarg(args);
  73.  
  74.     /* perform the car/cdr operations */
  75.     while (*adstr && consp(list))
  76.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  77.  
  78.     /* make sure the operation succeeded */
  79.     if (*adstr && list)
  80.     xlfail("bad argument");
  81.  
  82.     /* return the result */
  83.     return (list);
  84. }
  85.  
  86. /* xcons - construct a new list cell */
  87. NODE *xcons(args)
  88.   NODE *args;
  89. {
  90.     NODE *arg1,*arg2;
  91.  
  92.     /* get the two arguments */
  93.     arg1 = xlarg(&args);
  94.     arg2 = xlarg(&args);
  95.     xllastarg(args);
  96.  
  97.     /* construct a new list element */
  98.     return (cons(arg1,arg2));
  99. }
  100.  
  101. /* xlist - built a list of the arguments */
  102. NODE *xlist(args)
  103.   NODE *args;
  104. {
  105.     NODE ***oldstk,*arg,*list,*val,*last,*lptr;
  106.  
  107.     /* create a new stack frame */
  108.     oldstk = xlsave(&arg,&list,&val,NULL);
  109.  
  110.     /* initialize */
  111.     arg = args;
  112.  
  113.     /* evaluate and append each argument */
  114.     for (last = NIL; arg; last = lptr) {
  115.  
  116.     /* evaluate the next argument */
  117.     val = xlarg(&arg);
  118.  
  119.     /* append this argument to the end of the list */
  120.     lptr = consa(val);
  121.     if (last == NIL)
  122.         list = lptr;
  123.     else
  124.         rplacd(last,lptr);
  125.     }
  126.  
  127.     /* restore the previous stack frame */
  128.     xlstack = oldstk;
  129.  
  130.     /* return the list */
  131.     return (list);
  132. }
  133.  
  134. /* xappend - built-in function append */
  135. NODE *xappend(args)
  136.   NODE *args;
  137. {
  138.     NODE ***oldstk,*arg,*list,*last,*val,*lptr;
  139.  
  140.     /* create a new stack frame */
  141.     oldstk = xlsave(&arg,&list,&last,&val,NULL);
  142.  
  143.     /* initialize */
  144.     arg = args;
  145.  
  146.     /* evaluate and append each argument */
  147.     while (arg) {
  148.  
  149.     /* evaluate the next argument */
  150.     list = xlmatch(LIST,&arg);
  151.  
  152.     /* append each element of this list to the result list */
  153.     while (consp(list)) {
  154.  
  155.         /* append this element */
  156.         lptr = consa(car(list));
  157.         if (last == NIL)
  158.         val = lptr;
  159.         else
  160.         rplacd(last,lptr);
  161.  
  162.         /* save the new last element */
  163.         last = lptr;
  164.  
  165.         /* move to the next element */
  166.         list = cdr(list);
  167.     }
  168.     }
  169.  
  170.     /* restore previous stack frame */
  171.     xlstack = oldstk;
  172.  
  173.     /* return the list */
  174.     return (val);
  175. }
  176.  
  177. /* xreverse - built-in function reverse */
  178. NODE *xreverse(args)
  179.   NODE *args;
  180. {
  181.     NODE ***oldstk,*list,*val;
  182.  
  183.     /* create a new stack frame */
  184.     oldstk = xlsave(&list,&val,NULL);
  185.  
  186.     /* get the list to reverse */
  187.     list = xlmatch(LIST,&args);
  188.     xllastarg(args);
  189.  
  190.     /* append each element of this list to the result list */
  191.     while (consp(list)) {
  192.  
  193.     /* append this element */
  194.     val = cons(car(list),val);
  195.  
  196.     /* move to the next element */
  197.     list = cdr(list);
  198.     }
  199.  
  200.     /* restore previous stack frame */
  201.     xlstack = oldstk;
  202.  
  203.     /* return the list */
  204.     return (val);
  205. }
  206.  
  207. /* xlast - return the last cons of a list */
  208. NODE *xlast(args)
  209.   NODE *args;
  210. {
  211.     NODE *list;
  212.  
  213.     /* get the list */
  214.     list = xlmatch(LIST,&args);
  215.     xllastarg(args);
  216.  
  217.     /* find the last cons */
  218.     while (consp(list) && cdr(list))
  219.     list = cdr(list);
  220.  
  221.     /* return the last element */
  222.     return (list);
  223. }
  224.  
  225. /* xmember - built-in function 'member' */
  226. NODE *xmember(args)
  227.   NODE *args;
  228. {
  229.     NODE ***oldstk,*x,*list,*fcn,*val;
  230.     int tresult;
  231.  
  232.     /* create a new stack frame */
  233.     oldstk = xlsave(&x,&list,&fcn,NULL);
  234.  
  235.     /* get the expression to look for and the list */
  236.     x = xlarg(&args);
  237.     list = xlmatch(LIST,&args);
  238.     xltest(&fcn,&tresult,&args);
  239.     xllastarg(args);
  240.  
  241.     /* look for the expression */
  242.     for (val = NIL; consp(list); list = cdr(list))
  243.     if (dotest(x,car(list),fcn) == tresult) {
  244.         val = list;
  245.         break;
  246.     }
  247.  
  248.     /* restore the previous stack frame */
  249.     xlstack = oldstk;
  250.  
  251.     /* return the result */
  252.     return (val);
  253. }
  254.  
  255. /* xassoc - built-in function 'assoc' */
  256. NODE *xassoc(args)
  257.   NODE *args;
  258. {
  259.     NODE ***oldstk,*x,*alist,*fcn,*pair,*val;
  260.     int tresult;
  261.  
  262.     /* create a new stack frame */
  263.     oldstk = xlsave(&x,&alist,&fcn,NULL);
  264.  
  265.     /* get the expression to look for and the association list */
  266.     x = xlarg(&args);
  267.     alist = xlmatch(LIST,&args);
  268.     xltest(&fcn,&tresult,&args);
  269.     xllastarg(args);
  270.  
  271.     /* look for the expression */
  272.     for (val = NIL; consp(alist); alist = cdr(alist))
  273.     if ((pair = car(alist)) && consp(pair))
  274.         if (dotest(x,car(pair),fcn) == tresult) {
  275.         val = pair;
  276.         break;
  277.         }
  278.  
  279.     /* restore the previous stack frame */
  280.     xlstack = oldstk;
  281.  
  282.     /* return the result */
  283.     return (val);
  284. }
  285.  
  286. /* xsubst - substitute one expression for another */
  287. NODE *xsubst(args)
  288.   NODE *args;
  289. {
  290.     NODE ***oldstk,*to,*from,*expr,*fcn,*val;
  291.     int tresult;
  292.  
  293.     /* create a new stack frame */
  294.     oldstk = xlsave(&to,&from,&expr,&fcn,NULL);
  295.  
  296.     /* get the to value, the from value and the expression */
  297.     to = xlarg(&args);
  298.     from = xlarg(&args);
  299.     expr = xlarg(&args);
  300.     xltest(&fcn,&tresult,&args);
  301.     xllastarg(args);
  302.  
  303.     /* do the substitution */
  304.     val = subst(to,from,expr,fcn,tresult);
  305.  
  306.     /* restore the previous stack frame */
  307.     xlstack = oldstk;
  308.  
  309.     /* return the result */
  310.     return (val);
  311. }
  312.  
  313. /* subst - substitute one expression for another */
  314. LOCAL NODE *subst(to,from,expr,fcn,tresult)
  315.   NODE *to,*from,*expr,*fcn; int tresult;
  316. {
  317.     NODE ***oldstk,*carval,*cdrval,*val;
  318.  
  319.     if (dotest(expr,from,fcn) == tresult)
  320.     val = to;
  321.     else if (consp(expr)) {
  322.     oldstk = xlsave(&carval,&cdrval,NULL);
  323.     carval = subst(to,from,c